/*
 substandard lisp: an implementation of Standard Lisp.
    Copyright (C) 2011 Nicky Nickell

    substandard lisp is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/
#define APPLY1(fn, x) new lisp_pair(fn, new lisp_pair(x, NIL))
#define APPLYN(fn, x) new lisp_pair(fn, x)
#define QUOTE(x) APPLY1(new lisp_id('quote', env.oblist), x)
#define FUNCTION(x) APPLY1(new lisp_id('function', env.oblist), x)

var FTYPE_EXPR = 0;
var FTYPE_FEXPR = 1;
var FTYPE_MACRO = 2;

var ERROR_RETURN = 0;
var ERROR_GO = 1;
var ERROR_INTERNAL = 2;
var ERROR_USER = 3;

var TYPE_UNDEFINED = 0;
var TYPE_INTEGER = parseInt('00000001', 2);
var TYPE_FLOATING = parseInt('00000010', 2);
var TYPE_ID = parseInt('00000100', 2);
var TYPE_STRING = parseInt('00001000', 2);
var TYPE_PAIR = parseInt('00010000', 2);
var TYPE_VECTOR = parseInt('00100000', 2);
var TYPE_FUNCTION = parseInt('01000000', 2);
var TYPE_BOOLEAN = parseInt('10000000', 2);

var CLASS_FTYPE = TYPE_ID;
var CLASS_NUMBER = TYPE_INTEGER | TYPE_FLOATING;
var CLASS_CONSTANT = CLASS_NUMBER | TYPE_STRING | TYPE_VECTOR | TYPE_FUNCTION;
var CLASS_ANY = CLASS_CONSTANT | TYPE_ID | TYPE_PAIR | TYPE_BOOLEAN;
var CLASS_EBOOLEAN = CLASS_ANY;
var CLASS_ATOM = CLASS_ANY ^ TYPE_PAIR;

var ftype_strings = {};
ftype_strings[FTYPE_EXPR] = 'expr';
ftype_strings[FTYPE_FEXPR] = 'fexpr';
ftype_strings[FTYPE_MACRO] = 'macro';

var type_strings = {};
type_strings[TYPE_UNDEFINED] = 'undefined';
type_strings[TYPE_INTEGER] = 'integer';
type_strings[TYPE_FLOATING] = 'floating';
type_strings[TYPE_ID] = 'id';
type_strings[TYPE_STRING] = 'string';
type_strings[TYPE_PAIR] = 'pair';
type_strings[TYPE_VECTOR] = 'vector';
type_strings[TYPE_FUNCTION] = 'function';
type_strings[TYPE_BOOLEAN] = 'boolean';

var class_strings = {};
class_strings[CLASS_NUMBER] = 'number';
class_strings[CLASS_CONSTANT] = 'constant';
class_strings[CLASS_ANY] = 'any';
class_strings[CLASS_EBOOLEAN] = 'eboolean';
class_strings[CLASS_ATOM] = 'atom';

var builtins = {};
var interpreted_builtins = {};

var T = new lisp_object(TYPE_BOOLEAN, true);
var NIL = new lisp_object(TYPE_BOOLEAN, false);
NIL.car = NIL;
NIL.cdr = NIL;
var UNDEFINED = new lisp_object(TYPE_UNDEFINED, undefined);

function lisp_object(type, value) {
  this.value = value;
  this.type = type;
  this.constant = false;
}

lisp_integer.prototype = new lisp_object();
lisp_integer.constructor.name = lisp_integer;
function lisp_integer(value) {
  lisp_object.call(this, TYPE_INTEGER, BigInteger(value));
}

lisp_floating.prototype = new lisp_object();
lisp_floating.constructor.name = lisp_floating;
function lisp_floating(value) {
  lisp_object.call(this, TYPE_FLOATING, Number(value));
}

lisp_id.prototype = new lisp_object();
lisp_id.constructor.name = lisp_id;
function lisp_id(name, oblist) {
  if (oblist != undefined && oblist[name] != undefined) {
    return oblist[name];
  }
  lisp_object.call(this, TYPE_ID, name);
  this.proplist = {};
  this.flags = {};
  if (oblist != undefined) {
    oblist[name] = this;
  }
}

lisp_string.prototype = new lisp_object();
lisp_string.constructor.name = lisp_string;
function lisp_string(str) {
  if (/".*"/.test(str)) {
    str = eval(str);
  }
  lisp_object.call(this, TYPE_STRING, str);
}

lisp_vector.prototype = new lisp_object();
lisp_vector.constructor.name = lisp_vector;
function lisp_vector(vect) {
  lisp_object.call(this, TYPE_VECTOR, vect);
}

lisp_pair.prototype = new lisp_object();
lisp_pair.constructor.name = lisp_pair;
function lisp_pair(car, cdr) {
  lisp_object.call(this, TYPE_PAIR);
  this.car = car;
  this.cdr = cdr;
}

lisp_function.prototype = new lisp_object();
lisp_function.constructor.name = lisp_function;
function lisp_function(method, constant_args, optional_args, rest_arg, argument_masks, ftype) {
  lisp_object.call(this, TYPE_FUNCTION, method);
  this.constant_args = constant_args;
  this.optional_args = optional_args;
  this.rest_arg = rest_arg;
  this.argument_masks = argument_masks;
  this.ftype = ftype;
  this.interpreted = false;
}

lisp_function.prototype.parse_args = function () {};

lisp_function.prototype.arity_check = function (arglen) {
  if (this.rest_arg) {
    return this.constant_args <= arglen;
  } else {
    return this.constant_args <= arglen && arglen <= (this.constant_args + this.optional_args);
  }
}

builtin_function.prototype = new lisp_function();
builtin_function.constructor.name = builtin_function;
function builtin_function(method, arity, rest, argument_masks, ftype) {
  lisp_function.call(this, method, arity, 0, rest, argument_masks, ftype);
}

builtin_function.prototype.parse_args = function (a) {
  var ret = [];
  for (var i = 0; i < this.constant_args; i++) {
    ret.push(a[i]);
  }
  if (this.rest_arg) {
    var rest = [];
    for (var i = this.constant_args; i < a.length; i++) {
      rest.push(a[i]);
    }
    ret.push(rest);
  }
  return ret
}

interpreted_function.prototype = new lisp_function();
interpreted_function.constructor.name = interpreted_function;
function interpreted_function(expression, arguments, ftype) {
  var constant_args = 0;
  var optional_args = 0;
  var rest_arg = false;
  var args = [];
  var p = arguments;
  for (; p != NIL; p = p.cdr) {
    if (p.car.value == '&optional' || p.car.value == '&rest') {
      break;
    } else {
      args.push(p.car.value);
      constant_args++;
    }
  }

  if (p.car.value == '&optional') {
    p = p.cdr;
    for (; p != NIL; p = p.cdr) {
      if (p.car.value == '&rest') {
        break;
      } else {
        args.push(p.car.value);
        optional_args++;
      }
    }
  }

  if (p.car.value == '&rest') {
    p = p.cdr;
    args.push(p.car.value);
    rest_arg = true;
  }

  var method = function (a, env) {
      var result = NIL;
      var err = UNDEFINED;

      env.variables = env.variables.inner_block();

      for (var i = 0; i < a.length; i++) {
        env.variables._set(args[i], a[i]);
      }

      try {
        result = evaluate(expression, env);
      } catch (e) {
        err = e;
      } finally {
        env.variables = env.variables.outer;
        if (err != UNDEFINED) {
          throw err;
        } else {
          return result;
        }
      }
  }

  lisp_function.call(this, method, constant_args, optional_args, rest_arg, [], ftype);
  this.interpreted = true;
}

interpreted_function.prototype.parse_args = function (a) {
  var ret = [];
  var total = this.constant_args + this.optional_args;
  for (var i = 0; i < total; i++) {
    if (a[i] != undefined) {
      ret.push(a[i]);
    } else {
      ret.push(NIL);
    }
  }

  if (this.rest_arg) {
    if (a.length > total) {
      var rest = [];
      for (var i = total; i < a.length; i++) {
        rest.push(a[i]);
      }
      ret.push(rest);
    } else {
      ret.push(NIL);
    }
  }
  return ret;
}

function lisp_error(type, value, mess) {
  this.type = type;
  this.value = value;
  this.mess = mess;
}

function type_check(type, mask) {
  return Boolean(type & mask);
}

function homogenize_args(a) {
  var floating = false;
  var integer = false;
  for (var i = 0; i < a.length; i++) {
    if (a[i].type == TYPE_FLOATING) {
      floating = true;
    } else {
      integer = true;
    }
  }

  if (floating && integer) {
    var ret = [];
    for (var i = 0; i < a.length; i++) {
      if (a[i].type == TYPE_INTEGER) {
        ret.push(new lisp_floating(a[i].value.toJSValue()));
      } else {
        ret.push(a[i]);
      }
    }
    return ret;
  } else {
    return a;
  }
}

function mask_to_string(mask) {
  if (class_strings[mask] != undefined) {
    return class_strings[mask];
  } else {
    var set = [];
    for (i in type_strings) {
      if (i & mask) {
        set.push(type_strings[i]);
      }
    }
    if (set.length > 1) {
      return '{' + set.join(', ') + '}';
    } else {
      return set[0];
    }
  }
}

function namespace(up) {
  this.outer = up;
  this.dict = {};
}

namespace.prototype.get = function (key) {
  if (this.dict[key] != undefined) {
    return this.dict[key];
  } else {
    if (this.outer != undefined) {
      return this.outer.get(key);
    } else {
      return UNDEFINED;
    }
  }
}

namespace.prototype.set = function (key, value, constant) {
  if (this.dict[key] != undefined) {
    if (this.dict[key].constant == true) {
      throw new lisp_error(ERROR_INTERNAL, T, 'cannot change the value of constant: ' + key);
    } else {
      this.dict[key] = value;
    }
  } else {
    if (this.outer != undefined) {
      this.outer.set(key, value, constant);
    } else {
      this._set(key, value, constant);
    }
  }
}

namespace.prototype._set = function (key, value, constant) {
  value.constant = constant;
  this.dict[key] = value;
}

namespace.prototype.inner_block = function () {
  return new namespace(this);
}

function tokenize(expression) {
  var lines = expression.split('\n');
  var ret = [];
  for (var i = 0; i < lines.length; i++) {
    var line = lines[i];
    while (true) {
      line = line.replace(/^\s*/, '');
      var m = line.match(/^("(?:[^\\"]|\\.)*"|%.*|[(')]|#'|[^\s('"%)]*)|(.*)/g);
      if (m[0][0] != '%' && m[0] != '') {
        ret.push(m[0]);
      }
      if (m[1] != undefined) {
        line = m[1];
      } else {
        break;
      }
    }
  }
  return ret;
}

function build(tok, env) {
  if (tok.length == 0) {
    throw new lisp_error(ERROR_INTERNAL, T, 'unexpected EOF');
  }
  var t = tok.shift();
  switch (t) {
  case '(':
    if (tok[0] == ')') return NIL;
    var head = new lisp_pair(build(tok, env), NIL);
    var ptr = head;
    while (tok[0] != ')') {
      if (tok[0] == '.') {
        tok.shift();
        ptr.cdr = build(tok, env);
        break;
      }
      ptr.cdr = new lisp_pair(build(tok, env), NIL);
      ptr = ptr.cdr;
    }
    tok.shift();
    return head;
  case ')':
    throw new lisp_error(ERROR_INTERNAL, T, 'unexpected token \')\'');
  case '\'':
    return QUOTE(build(tok, env));
  case '#\'':
    return FUNCTION(build(tok, env));
  default:
    if (t.toLowerCase() == 't') {
      return T;
    } else if (t.toLowerCase() == 'nil') {
      return NIL;
    } else if (isNaN(t)) {
      if (/".*"/.test(t)) {
        return new lisp_string(t);
      } else {
        return new lisp_id(t, env.oblist);
      }
    } else {
      if (/\d*\.\d*/.test(t)) {
        return new lisp_floating(t);
      } else {
        return new lisp_integer(t);
      }
    }
  }
}

function print(a) {
  switch (a.type) {
  case TYPE_PAIR:
    var tmp = [];
    var p = a;
    while (true) {
      tmp.push(print(p.car));
      if (p.cdr == NIL) {
        break;
      } else if (!(p.cdr.type & TYPE_PAIR)) {
        tmp.push('.');
        tmp.push(print(p.cdr));
        break
      }
      p = p.cdr;
    }
    return '(' + tmp.join(' ') + ')';
  case TYPE_BOOLEAN:
    return a.value ? 'T' : 'NIL';
  case TYPE_VECTOR:
    var ret = [];
    for (var i = 0; i < a.value.length; i++) {
      ret.push(print(a.value[i]));
    }
    return '[' + ret.join(', ') + ']';
  case TYPE_INTEGER:
    return a.value.toString();
  case TYPE_FLOATING:
    return String(a.value);
  case TYPE_STRING:
    return '"' + a.value + '"';
  case TYPE_FUNCTION:
    if (a.interpreted) {
      return '#<LAMBDA>';
    } else {
      return '#<BUILTIN:' + a.value.name + '>';
    }
  default:
    return a.value;
  }
}

function evaluate(a, env) {
  switch (a.type) {
  case TYPE_BOOLEAN:
  case TYPE_STRING:
  case TYPE_INTEGER:
  case TYPE_FLOATING:
  case TYPE_VECTOR:
    return a;
  case TYPE_ID:
    return env.variables.get(a.value);
  case TYPE_PAIR:
    switch (a.car.type) {
    case TYPE_PAIR:
      var func = evaluate(a.car, env);
      break;
    case TYPE_FUNCTION:
      var func = a.car;
      break;
    default:
      var func = env.functions.get(a.car.value);
      if (func == UNDEFINED) {
        func = env.variables.get(a.car.value);
      }
      if (func == UNDEFINED) {
        throw new lisp_error(ERROR_INTERNAL, T, 'undefined function ' + a.car.value);
      }
    }

    if (func.type != TYPE_FUNCTION) {
      throw new lisp_error(ERROR_INTERNAL, T, 'not a function');
    }

    var args = a.cdr;

    var arglen = 0;
    for (var p = args; p != NIL; p = p.cdr) {
      arglen++;
    }

    if (!func.arity_check(arglen)) {
      throw new lisp_error(ERROR_INTERNAL, T, 'improper number of arguments for ' + print(func));
    }

    var arguments = [];
    for (var p = args; p != NIL; p = p.cdr) {
      arguments.push(p.car);
    }

    if (func.ftype == FTYPE_EXPR) {
      for (var i = 0; i < arguments.length; i++) {
        arguments[i] = evaluate(arguments[i], env);
      }
    }

    if (!func.interpreted) {
      for (var i = 0; i < func.constant_args; i++) {
        if (!type_check(arguments[i].type, func.argument_masks[i])) {
          throw new lisp_error(ERROR_INTERNAL, T, print(arguments[i]) + ' NOT ' + mask_to_string(func.argument_masks[i]) + ' FOR ' + print(func));
        }
      }

      if (func.rest_arg) {
        for (var i = func.constant_args; i < arguments.length; i++) {
          if (!type_check(arguments[i].type, func.argument_masks[func.constant_args])) {
            throw new lisp_error(ERROR_INTERNAL, T, print(arguments[i]) + ' NOT ' + mask_to_string(func.argument_masks[func.argument_masks.length - 1]) + ' FOR ' + print(func));
          }
        }
      }
    }

    arguments = func.parse_args(arguments);

    var return_value = func.value(arguments, env);

    if (func.ftype == FTYPE_MACRO) {
      return_value = evaluate(return_value, env);
    }

    return return_value;
  }
}

function interpreter() {
  this.result = '';
  this.exception = false;
  this.variables = new namespace();
  this.functions = new namespace();
  this.environment = {
    'variables': this.variables,
    'functions': this.functions,
    'oblist': {},
    'side_effects': ''
  };
}

interpreter.prototype.evaluate = function (expr) {
  this.exception = false;
  this.result = '';
  this.environment.side_effects = '';
  try{
    this.result = print(evaluate(build(tokenize(expr), this.environment), this.environment));
  } catch(e) {
    this.exception = true;
    switch (e.type) {
    case ERROR_INTERNAL:
      this.result = '***** ' + e.mess;
      this.environment.variables.set('EMSG*', new lisp_string(e.mess));
      break;
    case ERROR_GO:
      this.result = '***** GO out of context';
      this.environment.variables.set('EMSG*', new lisp_string('***** GO out of context'));
      break;
    case ERROR_RETURN:
      this.result = '***** RETURN out of context';
      this.environment.variables.set('EMSG*', new lisp_string('***** RETURN out of context'));
      break;
    case ERROR_USER:
      this.result = '++++ ' + print(e.value) + ' ' + print(e.mess);
      this.environment.variables.set('EMSG*', e.mess);
      break;
    default:
      this.result = e.message;
      this.environment.variables.set('EMSG*', new lisp_string(e.message));
    }
  }
}

interpreter.prototype.initialize = function () {
  this.variables.set('NIL', NIL, true);
  this.variables.set('T', T, true);
  this.variables.set('EMSG*', NIL);
  this.variables.set('*RAISE', NIL);
  this.variables.set('*GSNUM', new lisp_integer('1'));

  for (func in builtins) {
    this.functions.set(func, builtins[func], true);
  }

  for (func in interpreted_builtins) {
    this.evaluate(interpreted_builtins[func]);
    this.functions.get(func).constant = true;
  }
}
